home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / sources.lha / sources / sys / condition.t < prev    next >
Encoding:
Text File  |  1988-02-05  |  5.1 KB  |  136 lines
  1. (herald condition (env tsys))
  2.  
  3. ;;; Copyright (c) 1985 Yale University
  4. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  5. ;;; This material was developed by the T Project at the Yale University Computer 
  6. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  7. ;;; and to use it for any purpose is granted, subject to the following restric-
  8. ;;; tions and understandings.
  9. ;;; 1. Any copy made of this software must include this copyright notice in full.
  10. ;;; 2. Users of this software agree to make their best efforts (a) to return
  11. ;;;    to the T Project at Yale any improvements or extensions that they make,
  12. ;;;    so that these may be included in future releases; and (b) to inform
  13. ;;;    the T Project of noteworthy uses of this software.
  14. ;;; 3. All materials developed as a consequence of the use of this software
  15. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  16. ;;;    of acknowledging credit in academic research.
  17. ;;; 4. Yale has made no warrantee or representation that the operation of
  18. ;;;    this software will be error-free, and Yale is under no obligation to
  19. ;;;    provide any services, by way of maintenance, update, or otherwise.
  20. ;;; 5. In conjunction with products arising from the use of this material,
  21. ;;;    there shall be no use of the name of the Yale University nor of any
  22. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  23. ;;;    without prior written consent from Yale in each case.
  24. ;;;
  25.  
  26. ;;;; Signals and errors
  27. ;;;  These are probably still too heavy weight!
  28.  
  29. ;;;  A condition is signaled by being called.
  30.  
  31. (define (make-condition-type default-handler string id continuable?)
  32.   (let ((handler default-handler))
  33.     (object (lambda (fmt args)
  34.               (labels ((instance
  35.                         (object (lambda ()
  36.                                   (receive vals (handler instance)
  37.                                     (if continuable?
  38.                                         (apply return vals)
  39.                                         (not-continuable))))
  40.                           ((print-signal self port)
  41.                            (format port "~&** ~A: " string)
  42.                            (apply format port fmt args)
  43.                            (fresh-line port))
  44.                           ((print-type-string self) string))))
  45.                 (instance)))
  46.       ((condition-handler self) handler)
  47.       ((set-condition-handler self val) (set handler val))
  48.       ((identification self) id)
  49.       ((print-type-string self) "Condition"))))
  50.  
  51. ;;; Operations on conditions
  52.  
  53. (define-settable-operation (condition-handler condition-type))
  54. (define set-condition-handler (setter condition-handler))
  55.  
  56. ;;; Operation on condition instance
  57.  
  58. (define-operation (print-signal instance port))
  59.  
  60.  
  61. ;;; Utility for CONDITION-BIND (?)
  62.  
  63. (define (cons-condition-handler proc type)
  64.   (let ((proc (enforce procedure? proc))
  65.         (punt (condition-handler type)))
  66.     (lambda (err)
  67.       (proc err punt))))
  68.  
  69. ;;; ---------- Error conditions.
  70.  
  71. ;;; Error conditions in general
  72.  
  73. (lset *the-error* nil)
  74. (lset *reporting-error?* nil)
  75. (lset *abort-error-report* nil)
  76.  
  77. (define (make-error-type string id)
  78.   (make-condition-type standard-error string id t))
  79.  
  80. (define (make-non-continuable-error-type string id)
  81.   (make-condition-type standard-error string id nil))
  82.  
  83. ;++ if the format statement doesn't have enough args
  84. ;++ you get a misleading error.
  85.  
  86. (define (standard-error err)
  87.   (catch error-point
  88.     (bind ((*the-error* (cons err error-point)))
  89.       (catch abort
  90.         (bind ((*reporting-error?* t)
  91.                (*abort-error-report* abort))
  92.           (let ((out (error-output)))
  93.             ;; don't use ~2& - Z-FORMAT can't cope
  94. ;++            (format out "~&~%")
  95.             (print-signal err out))))
  96.       (breakpoint))))
  97.  
  98. ;++ user versus system errors
  99. ;; the error system needs
  100. ;; format, i/o
  101.  
  102. (define (signal-error error-type f-string f-args)
  103.   (cond ((not *reporting-error?*)
  104.          (error-type f-string f-args))
  105.         ((neq? *reporting-error?* '*reporting-error?*)
  106.          (bind ((*reporting-error?* '*reporting-error?*)) 
  107.            (format (error-output) "~&**** Error while reporting error!~%")
  108.            (*abort-error-report* nil)))
  109.         (else
  110.          (apply vm-error 'signal f-string f-args))))
  111.  
  112. ;;; Particular error conditions.
  113.  
  114. (define *unspecific-error-type*
  115.   (make-error-type "Error" '*unspecific-error-type*))
  116.  
  117. (define *non-continuable-error-type*
  118.   (make-non-continuable-error-type "Error" '*non-continuable-error-type*))
  119.  
  120. (define (syntax-error f-string . f-args)
  121.   (signal-error *syntax-error-type* f-string f-args))
  122.  
  123. (define *syntax-error-type*
  124.   (make-error-type "Syntax error" '*syntax-error-type*))
  125.  
  126. (define (read-error port f-string . f-args)
  127. ;++ flush  (clear-input port) ;++ why is this needed??
  128.   (signal-error *read-error-type*
  129.                 (append (cond ((pair? f-string) f-string)
  130.                               (else (list f-string)))
  131.                         '("~&  (line ~S of port ~S)"))
  132.                 (append f-args (list (vpos port) port))))
  133.  
  134. (define *read-error-type*
  135.   (make-error-type "Read error" '*read-error-type*))
  136.